{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Semantic.Task.Files
  ( Files
  , Destination (..)
  , Source (..)
  , readBlob
  , readBlobs
  , readBlobPairs
  , readProject
  , findFiles
  , write
  , Handle (..)
  , FilesC(..)
  , FilesArg(..)
  ) where

import           Analysis.File
import           Analysis.Project
import           Control.Algebra
import           Control.Effect.Error
import           Control.Exception
import           Control.Monad.IO.Class
import           Data.Blob
import           Data.Blob.IO
import qualified Data.ByteString.Builder as B
import           Data.Handle
import           Prelude hiding (readFile)
import           Semantic.IO
import           Source.Language (Language)
import qualified System.IO as IO hiding (withBinaryFile)
import qualified System.Path as Path
import qualified System.Path.IO as IO (withBinaryFile)

data Source blob where
  FromPath       :: File Language                   -> Source Blob
  FromHandle     :: Handle 'IO.ReadMode             -> Source [Blob]
  FromPathPair   :: File Language -> File Language  -> Source BlobPair
  FromPairHandle :: Handle 'IO.ReadMode             -> Source [BlobPair]

data Destination = ToPath Path.AbsRelFile | ToHandle (Handle 'IO.WriteMode)

-- | An effect to read/write 'Blob's from 'Handle's or 'FilePath's.
data Files (m :: * -> *) k where
  Read :: Source a -> Files m a
  ReadProject :: Maybe Path.AbsRelDir -> Path.AbsRelFileDir -> Language -> [Path.AbsRelDir] -> Files m Project
  FindFiles :: Path.AbsRelDir -> [String] -> [Path.AbsRelDir] -> Files m [Path.AbsRelFile]
  Write :: Destination -> B.Builder -> Files m ()


newtype FilesC m a = FilesC
  { -- | Run a 'Files' effect in 'IO'
    runFiles :: m a
  }
  deriving (Functor, Applicative, Monad, MonadFail, MonadIO)

instance (Has (Error SomeException) sig m, MonadFail m, MonadIO m) => Algebra (Files :+: sig) (FilesC m) where
  alg hdl sig ctx = case sig of
    L op -> (<$ ctx) <$> case op of
      Read (FromPath path)                                    -> readBlobFromFile' path
      Read (FromHandle handle)                                -> readBlobsFromHandle handle
      Read (FromPathPair p1 p2)                               -> readFilePair p1 p2
      Read (FromPairHandle handle)                            -> readBlobPairsFromHandle handle
      ReadProject rootDir dir language excludeDirs            -> readProjectFromPaths rootDir dir language excludeDirs
      FindFiles dir exts excludeDirs                          -> findFilesInDir dir exts excludeDirs
      Write (ToPath path) builder                             -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder))
      Write (ToHandle (WriteHandle handle)) builder           -> liftIO (B.hPutBuilder handle builder)
    R other -> FilesC (alg (runFiles . hdl) other ctx)

readBlob :: Has Files sig m => File Language -> m Blob
readBlob file = send (Read (FromPath file))

-- Various ways to read in files
data FilesArg
  = FilesFromHandle (Handle 'IO.ReadMode)
  | FilesFromPaths [File Language]

-- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's.
readBlobs :: Has Files sig m => FilesArg -> m [Blob]
readBlobs (FilesFromHandle handle) = send (Read (FromHandle handle))
readBlobs (FilesFromPaths paths)   = traverse (send . Read . FromPath) paths

-- | A task which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's.
readBlobPairs :: Has Files sig m => Either (Handle 'IO.ReadMode) [(File Language, File Language)] -> m [BlobPair]
readBlobPairs (Left handle) = send (Read (FromPairHandle handle))
readBlobPairs (Right paths) = traverse (send . Read . uncurry FromPathPair) paths

readProject :: Has Files sig m => Maybe Path.AbsRelDir -> Path.AbsRelFileDir -> Language -> [Path.AbsRelDir] -> m Project
readProject rootDir dir lang excludeDirs = send (ReadProject rootDir dir lang excludeDirs)

findFiles :: Has Files sig m => Path.AbsRelDir -> [String] -> [Path.AbsRelDir] -> m [Path.AbsRelFile]
findFiles dir exts paths = send (FindFiles dir exts paths)

-- | A task which writes a 'B.Builder' to a 'Handle' or a 'FilePath'.
write :: Has Files sig m => Destination -> B.Builder -> m ()
write dest builder = send (Write dest builder)
